{todo: move some procedures to modules}
program SelfMadeDB;
uses crt, XORCRYPT;
const
  v       = '1.1b';      {version}
type
  header = string[5];
  {header for all smdb files. provides recognization of positive decryptions}
type
  fresults = array[0..100] of integer;

type
  agent = record         {main class of records}
    name: string[25];
    adress: string[50];  {Russian-type}
    rank: string[10];
    rel: string[10];     {reliability}
    dob: string[10]      {date of birth xx.xx.xxxx}
  end;
type
  config = record homedir: string[100];
  end;                   {configuration file}

var
  path, password, bindir: string;
  {bindir - directory of binary file}
  f       : file of agent; {main file}
  i, l    : byte;
  a       : agent;       {buffer}
  e       : boolean;
  {head:header;}{header}
  pascorrect: boolean;
  closeprogram: boolean;

  {procedure of crypting the files. usage:
  Crypt(<filename of file to crypt>, <password>, <file-header>)}

procedure Crypt(var finP, password: string; fheader: header);
var
  fin, bufff: text;
  dirs, buffp: string;
  i, l    : byte;
  cheader : header;      {counters}
  b       : char;        {buffer char}
begin
  {$I-}Assign(fin, finP);
  {$I+}
  if IOresult <> 0 then
    WriteLn('ERROR');
  buffp := 'buffer.dat';
  Assign(bufff, buffp);
  {Assigning temporary files}
  {$I-}Reset(fin);
  {$I+}
  if IOresult <> 0 then begin
      WriteLn('Error read');
      Readkey;
    end;
  {$I-}ReWrite(bufff);
  {$I+}
  if IOresult <> 0 then begin
      WriteLn('Error write');
      readkey;
    end;
  {adding header to buffer file}
  Write(bufff, fheader);
  {now coping info from fin to buff}
  while not EoF(fin) do begin
      Read(fin, b);
      Write(bufff, b);
    end;
  Close(bufff);
  Close(fin);
  {both files closed}
  {crypting from buffer to fin, replacing uncripted info with crypted}
  XorCryptF(bufff, fin, password);
  Erase(bufff);          {deleting buffer file}
end;

{procedure of decrypting the files. correct - flag, true when correct password)
usage:
Decrypt(<filename of file to decrypt>, <password, <file-header>, <boolean-flag>)}
{decrypting aborts when password is incorrect. no changes to unput files in this
case will do}

procedure DeCrypt(var finP, password: string; Fheader: header; var correct:
  boolean);
var
  fin, buff: text;
  i, l    : byte;
  b       : char;
  Cheader : header;
begin
  Assign(fin, finP);
  Assign(buff, 'buff.tmp');
  {decryting fin to buffer file}
  XorCryptF(fin, buff, password);
  {$I-}Reset(buff);
  {$I+}
  if IOresult <> 0 then begin
      WriteLn('E');
      ReadKey
    end;
  {reading header}
  Read(buff, Cheader);
  correct := false;
  correct := (Cheader = Fheader);
  {if header is correct then correct - true}
  {this returns 'false' if password is incorrect}
  if correct then begin
      ReWrite(fin);
      {copying info from buffer file to inp. crypted data deleted}
      while not EoF(buff) do begin
          Read(buff, b);
          Write(fin, b);
        end;
      Close(fin);        {closing file with decrypted data}
    end;
  Close(buff);
  {deleting buffer file}
  {$I-}Erase(buff);
  {$I+}
  if IOresult <> 0 then begin
      WriteLn('Error');
      ReadKey;
    end;
end;

{Function, returns true if file <name> exists in working directory}

function FILEXIST(name: string): boolean;
var
  fm      : byte;
  f       : file;
  b       : boolean;
begin
  fm := FileMode;
  FileMode := 0;
  assign(f, name);
  {$I-}reset(f);
  {$I+}
  b := IOResult = 0;
  if b then
    close(f);
  filexist := b;
  FileMode := fm;
end;

{Procedure of reading from keyboard agent-file to buffer variable}

procedure Input(var b: agent);
begin
  with b do begin
      Write('>Enter name of agent: ');
      ReadLn(name);
      Write('>Adress in RU format: ');
      ReadLn(adress);
      Write('>Rank: ');
      ReadLn(rank);
      Write('>Reliability of agent: ');
      ReadLn(rel);
      Write('>Date of birth (dd.mm.yyyy): ');
      ReadLn(dob);
    end;
end;

{procedure that prints one record to screen}

procedure Output(b: agent; r: byte);
begin
  with b do begin
      WriteLn('[ ID ', r, ' ]');
      WriteLn('>Name: ', name);
      WriteLn('>Date of birth: ', dob);
      WriteLn('>Dislocation: ', adress);
      WriteLn('>Rank: ', rank);
      WriteLn('>Reliability: ', rel);
    end;
end;

{procedure that deletes ONE id #<id> in file FPATH}

procedure deleteid(fpath: string; id: byte);
var
  inp, buff: file of agent;
  k       : byte;
  b       : agent;
begin
  Assign(inp, fpath);
  Assign(buff, 'buf_' + fpath[1] + '.tmp');
  {buff - buffer file}
  {opening files}
  Reset(inp);
  ReWrite(buff);
  k := 1;
  while not EoF(inp) do begin
      Read(inp, b);
      {reading source and copyng to buffer file if source id is not the delete id <id> }
      if k <> id then Write(buff, b);
      inc(k);
    end;

  {closing buffer and input files}
  Close(inp);
  Close(buff);
  ReWrite(inp);
  Reset(buff);
  {reseted input file and starting coping buffer back to input file}
  while not EoF(buff) do begin
      Read(buff, b); Write(inp, b);
    end;
  {now buffer file consists all id's except <id>}
  {closing files}
  Close(buff);
  Close(inp);
  {deleting buffer file}
  Erase(buff);
end;

{procedure of finding id's with identical records parameters}
{elelemtid - id of parameter}
{element id: 1:name 2:adress 3:rank 4:reliability; 5:dob}
{results - array [0..100] of integer, where [1..100] - found record
ids with identical strings, and [0] - is quantum of results}

procedure find(fpath, stext: string; elementid: byte; var results: fresults);
var
  i, n    : byte;
  b       : agent;
  element : string;
  inp     : file of agent;
  head    : header;
begin
  {opening files with reading permissions}
  Assign(inp, fpath);
  Reset(inp);
  i := 1;                {result id}
  n := 1;                {number of result}
  results[0] := 0;       {by default nothing found}

  {starting searching}
  while not EoF(inp) do begin
      Read(inp, b);
      {changing element depending on <elementid>}
      with b do
        case elementid of
          1: element := name;
          2: element := adress;
          3: element := rank;
          4: element := rel;
          5: element := dob;

        end;

      if element = stext then begin
          results[n] := i; {i - id of record}
          results[0] := n; {n - quantum of results}
        end;
      inc(i);
      inc(n);
    end;
  Close(inp);
end;

{procedure of adding record to exiting file; always adds record to end of file}

procedure addid(fpath: string; r: agent);
var
  b       : agent;
  inp, buff: file of agent;
begin
  Assign(inp, fpath);
  Assign(buff, 'b_' + fpath[1]);
  Reset(inp);
  ReWrite(buff);
  while not EoF(inp) do begin
      Read(inp, b);
      Write(buff, b);
    end;
  Write(buff, r);
  Close(inp);
  Close(buff);
  ReWrite(inp);
  Reset(buff);
  while not EoF(buff) do begin
      Read(buff, b); Write(inp, b);
    end;
  Close(buff);
  Close(inp);
  Erase(buff);
end;

{procedure of printing file}

procedure PrintFile(fpath: string);
var
  k       : integer;
  inp     : file of agent;
begin
  ClrScr;
  WriteLn('Printing ', fpath);
  {$I-}
  Assign(inp, fpath);
  Reset(inp);
  {$I+}

  if IOresult = 0 then begin
      k := 1;
      while not (eof(inp)) do begin
          read(inp, a);
          Output(a, k);
          inc(k);
        end;
    end
  else
    WriteLn('Error reading');
  ReadKey;
  {waiting for responce}
end;

{procedure of printing id}
{used while printing find results}

procedure PrintId(fpath: string; id: integer);
var
  k       : integer;
  inp     : file of agent;
begin
  {$I-}
  Assign(inp, fpath);
  Reset(inp);
  {$I+}

  if IOresult = 0 then begin
      k := 1;
      while not (eof(inp)) do begin
          read(inp, a);
          if (id = k) then
            Output(a, k);
          inc(k);
        end;
    end

  else
    WriteLn('Error reading');
  Close(inp);
end;

{procedure that creates new file and asks to fill the file with records}

procedure CreateFile(fpath: string; k: integer);
var
  q       : integer;
  b       : agent;
  inp     : file of agent;
begin
  ClrScr;
  WriteLn('[ ', fpath, ' ]');
  WriteLn('Creating file with ', k, ' records');
  Assign(inp, fpath);
  {$I-}Rewrite(inp);
  {$I+}
  if IOresult <> 0 then
    WriteLn('Error on rewrite')
  else begin
      for i := 1 to k do begin
          WriteLn('[ ', i, ' ]');
          Input(b);
          write(inp, b);
        end;
    end;
  Close(inp);
end;

{procedure of printing main  processing menu}

procedure PrintMenu(fpath, hdir: string);
begin
  ClrScr;
  WriteLn('[ ', hdir, '> ', fpath, ' ]');
  WriteLn('1. Add new record');
  WriteLn('2. Delete exiting record');
  WriteLn('3. Delete file');
  WriteLn('4. Read file');
  WriteLn('5. Search in file');
  WriteLn('6. Create new file');
  WriteLn('7. Open another file');
  WriteLn('8. Exit');
  WriteLn('9. Change working directory');
end;

{procedure of adding records menu}

procedure AddMenu(fpath: string);
var
  k, num  : integer;
  b1      : agent;
begin
  ClrScr;
  WriteLn('[ ', fpath, ' ]');
  WriteLn('Add records menu');
  Write('How many records do you want to add? :');
  ReadLn(num);
  for i := 1 to num do begin
      Input(b1);
      AddId(path, b1);
    end;
end;

{procedure of deleting id menu}

procedure DeleteIdMenu(fpath: string);
var
  num, bbff: integer;
  snum    : string;
begin
  ClrScr;
  WriteLn('[ ', fpath, ' ]');
  WriteLn('Delete record menu');
  Write('Delete id (0 to cancel): ');
  ReadLn(snum);
  Val(snum, num, bbff);
  if num <> 0 then
    DeleteId(fpath, num)
  else
    WriteLn('Canceling');
end;

{procedure of changing work directory}
{uses configuration files}
{if change - true - forcing to rewrite config and change directory}
{if procedure found file <configP> then reads directory path from file,
else asking for homedir then writes to file <configP> in start directory and changes work dir}

procedure ChangeHomeDir(configP: string; var hdir, bdir: string; change:
  boolean; var changed: boolean);
var
  configF : file of config;
  conf    : config;
  good, succes: boolean;
  hdirt, cdir: string;
begin
  ClrScr;
  repeat
    begin
      good := true;
      succes := false;
      changed := false;
      {changed - if directory was changed during processing. needed to correctly close files}

      if FilExist(configP) and not change then begin
          WriteLn('File exist');
          Assign(configF, configP);
          Reset(configF);
          Read(configF, conf);
          WriteLn('Readed config: [', conf.homedir, ']');
          hdir := conf.homedir;
          Close(configF);
          good := true;
          succes := true;
          {$I-}ChDir(hdir);
          {$I+}
          if IOresult <> 0 then begin
              WriteLn('Changing directory failed');
              good := false;
              ReadKey;
            end
        end;

      if (not FilExist(ConfigP) xor not good) or change then
        repeat
          begin
            if change then
              {$I-}Chdir(bdir)
            else
              WriteLn('File not exist in ', hdir);
            WriteLn('Going back to ', bdir);
            {$I+}        {going back to binary file directory}
            Assign(configF, configP);
            ReWrite(configF);
            if not Filexist(configp) then
              WriteLn('Config file ', configP, ' not found');

            Write('Change working dir (current is ', hdir, ') to: ');
            ReadLn(hdir);
            {$I-}ChDir(hdir);
            {$I+}
            if IOresult <> 0 then begin
                WriteLn('Changing directory failed');
                good := false;
                ReadKey;
              end
            else begin
                WriteLn('Succesfully changed directory to ', hdir);
                changed := true;
                conf.homedir := hdir;
                Write(configF, conf);
                Close(configF);
                GetDir(0, bdir);
                good := true;
                succes := true; {Writing binary derictory to bdir}
              end;

        end until good;

      {$I-}Chdir(hdir);
      {$I+}
      if IOresult <> 0 then
        WriteLn('Error (', ioresult, ') while changing to', hdir);
  end until succes;
  GetDir(0, cdir);
  WriteLn('Now home directory is <', cdir, '>');
  ReadKey;
  CLrScr;
end;

procedure OpenFileMenu(var fpath: string; var fpassword: string; head: header;
  var succes: boolean);
var
  close   : boolean;
  fpatht, fpasswordt: string;
begin
  ClrScr;
  WriteLn('Open file menu');
  succes := false;
  close := false;
  repeat
    begin
      fpatht := '';
      fpasswordt := '';  {changing temp vars}
      Write('Enter filename to open (or enter to back to menu): ');
      ReadLn(fpatht);
      close := false;
      close := (Ord(fpatht[1]) = 0) or (fpatht = ''); {if the string is blank}
      if close then begin
          succes := false;
          break;
          WriteLn('Closing');
        end
      else begin
          if FILEXIST(fpatht) then begin {cheking existanse of file}
              Write('Enter password to file: ');
              ReadLn(fpasswordt);
              DeCrypt(fpatht, fpasswordt, head, succes);
              if not succes then
                WriteLn('Incorrect Password on open') {cheking password correction}
              else begin
                  close := false;
                  fpath := fpatht;
                  fpassword := fpasswordt; {writing temp var. to working var}
                  Crypt(fpath, fpassword, head);
                end;
            end
          else
            WriteLn('File not exist');
        end;
  end until (succes or close);

end;

procedure CreateFileMenu(var fpath: string; var fpassword: string; head: header;
  var succes: boolean);
var
  k       : byte;
  fpatht, fpasswordt: string;
  close   : boolean;
begin
  repeat
    begin                {cycling until got back to menu or succesifully created new file}
      ClrScr;
      WriteLn('Creating file menu');
      fpatht := '';
      fpasswordt := '';
      Write('Enter filename to create [8 chars max] (or esc to exit menu): ');
      ReadLn(fpatht);
      close := false;
      close := (ord(fpatht[1]) = 0) or (fpatht = '');
      if close then begin
          succes := false;
          break;
        end
      else begin         {closing cycle to go back to menu}
          succes := not filexist(fpatht);
          if not FILEXIST(fpatht) then begin
              Write('Enter password to new file: ');
              ReadLn(fpasswordt);
              Write('Number of records: ');
              ReadLn(k);
              CreateFile(fpatht, k);
              ClrScr;
              PrintFile(fpatht);
              {printing file content}
              Crypt(fpatht, fpasswordt, head); {crypting file}
              fpath := fpatht;
              fpassword := fpasswordt; {changing back global workfile}
            end
          else begin
              WriteLn('Error: file already exist!');
              ReadKey;
              ClrScr;
            end;
        end;
  end until succes;
end;

procedure DeleteFile(var fpath, fpassword: string; var head: header);
var
  ch      : char;
  good    : boolean;
var
  ffile   : text;
begin
  ClrScr;
  WriteLn('Are you sure to delete ? y/n: ', fpath);
  repeat ReadLn(ch);
  until (UpCase(ch) = 'Y') or (UpCase(ch) = 'N');
  if UpCase(ch) = 'Y' then begin
      Assign(ffile, fpath);
      Erase(ffile);
      WriteLn('1. Open exiting file');
      WriteLn('2. Create new file');
      WriteLn('3. Exit');
      repeat ReadLn(ch)until (ch = '1') or (ch = '2') or (ch = '3');   
      case ch of
        '1': OpenFileMenu(fpath, fpassword, head, good);
        '2': CreateFileMenu(fpath, fpassword, head, good);
		'3': Halt;
      end;
      ClrScr;
    end;
end;

procedure FindMenu(var fpath: string);
var
  i       : fresults;
  k       : integer;
  c       : char;
  stext   : string;
  correct : integer;
  sindex  : byte;
begin
  {fresults - array [1..1000] of integer - array of positive results; 0 element consist number of records}
  {element id: 1:name 2:adress 3:rank 4:reliability; 5:dob}
  repeat
    begin
      ClrScr;
      WriteLn('Find menu'); {printing searching ui}
      WriteLn('Find: ');
      WriteLn('0. Cancel');
      WriteLn('1. Name');
      WriteLn('2. Adress');
      WriteLn('3. Rank');
      WriteLn('4. Reliability');
      WriteLn('5. Date of Birth');
      ReadLn(c);         {reading input}
      Val(c, sindex, correct); {conventering input char to byte}
      if (sindex <> 0) then
        WriteLn('Index: ', sindex) {just printing selected index}
      else
        WriteLn('Closing finding menu'); {if writed '0' then close menu}
      if (correct = 0) and (sindex < 5) and (sindex > 0) then begin
          Write('Search for: ');
          ReadLn(stext);
          find(fpath, stext, sindex, i); {searching for index}
          ClrScr;
          Writeln('Search completed with ', i[0], ' results');
          if (i[0] <> 0) then begin
              WriteLn('Finded ', i[0]);
              WriteLn('Printing...');
              for k := 1 to i[0] do
                PrintId(fpath, i[k]);
            end

          else
            WriteLn('Nothing found');
        end
      else
        if (sindex > 5) then
          WriteLn('Incorrect Input');
      ReadKey;
  end until c = '0';

end;
{main procedure; work with file 'fpath' opened with password 'fpassword'}

procedure MainCycle(var fpath: string; var fpassword: string; head: header; var
  code: char; confp: string; var hdir, bdir: string);
var
  hdirt, fpatht, fpasswordt: string;
  close, succes: boolean;
  dirchanged: boolean;
begin
  ClrScr;
  dirchanged := false;
  fpatht := fpath;
  {temporary filename; to correctly open new files and close current files}
  fpasswordt := fpassword; {same as ^}
  hdirt := hdir;
  PrintMenu(fpatht, hdir); {printing file menu with header 'fpatht'}
  ReadLn(code);          {reading input key}
  DeCrypt(fpatht, fpasswordt, head, succes); {decrypting file before work}
  case code of
    '1': AddMenu(fpath); {in this menu user adds records}
    '2': DeleteIdMenu(fpath); {in this menu user deletes records}
    '3': DeleteFile(fpath, fpassword, head);
    {in this menu user deletes exiting db}
    '4': PrintFile(fpath); {just prints exiting records}
    '8': WriteLn('Closing application...');
    '9': ChangeHomeDir(confP, hdir, bdir, true, dirchanged);
    {in this menu user changes home directory}
    '6': CreateFileMenu(fpath, fpassword, head, succes); {creating new file}
    '7': OpenFileMenu(fpath, fpassword, head, succes); {opening another file}
    '5': FindMenu(fpath); {searching menu}

  end;
  if dirchanged then
    code := 'r';         {closing the file and entering matrix}
  ChDir(hdirt);
  Crypt(fpatht, fpasswordt, head);
  ChDir(hdir);
  {crypting back}
end;

{main working procedure}
{fpath - variable, password - variable;
head - header - string [5] - provides recognization of positive dectyptions}
{confp - name of configuration file }

procedure EnterTheMatrix(var fpath: string; var fpassword: string; head: header;
  confp: string);
var
  f       : file of agent;
  c       : char;
  good    : boolean;
  hdir, bdir: string;
  buff    : boolean;
begin
  GetDir(0, bdir);
  ClrScr;
  ChangeHomeDir(confp, hdir, bdir, false, buff);
  repeat
    begin
      WriteLn(hdir, '>');
      WriteLn('>Welcome to SelfMadeDB Secure database processing program v', v);
      WriteLn('>Using secure databases');
      WriteLn('1. Open exiting file');
      WriteLn('2. Create new file');
      WriteLn('3. Exit');
      repeat ReadLn(c)until (c = '1') or (c = '2') or (c = '3');
      if (c = '3') or (Ord(c) = 0) then
        Halt;
      ClrScr;
      case c of
        '1': OpenFileMenu(fpath, fpassword, head, good);
        '2': CreateFileMenu(fpath, fpassword, head, good);
      end;
      repeat
        MainCycle(fpath, fpassword, head, c, confp, hdir, bdir);
        {main file processing cycle}
      until (c = '8') or (c = 'r');
      if c = '8' then
        Halt;            {if code 8 then exit matrix }
      if c = 'r' then
        good := false;   {to not to exit program when directory is changed}
      ClrScr;
  end until good;
end;

begin
  ClrScr;
  EnterTheMatrix(path, password, '12345', 'smdbcfg.ini');
end.
